unit TrayIcon;

interface
uses Windows, Messages, Classes, Graphics, SysUtils, Forms, Controls, Menus,
     ShellAPI;
     
const
  WM_YBAPPFORMSHOW = WM_USER + 110;
type
  TMouseButtons = set of TMouseButton;

  TTrayIcon = class(TComponent)
  private
    FHandle: HWnd;
    FActive: Boolean;
    FAdded: Boolean;
    FEnabled: Boolean;
    FClicked: TMouseButtons;
    FIconIndex: Integer;
    FInterval: Word;
    FIconData: TNotifyIconData;
    FIcon: TIcon;
    FHint: string;
    FHideMainForm: Boolean;
    FMinimizeToTray: Boolean;
    FMinimizeAllForm: Boolean;
    FShowDesign: Boolean;
    FPopupMenu: TPopupMenu;
    FOnClick: TMouseEvent;
    FOnDblClick: TNotifyEvent;
    FOnMouseMove: TMouseMoveEvent;
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
    OldAppProc, NewAppProc: Pointer;
    procedure ChangeIcon;
    procedure SendCancelMode;
    function CheckMenuPopup(X, Y: Integer): Boolean;
    function CheckDefaultMenuItem: Boolean;
    procedure SetHint(const Value: string);
    procedure SetHideMainForm(Value: Boolean);
    procedure SetIcon(Value: TIcon);
    procedure SetPopupMenu(Value: TPopupMenu);
    procedure Activate;
    procedure Deactivate;
    procedure SetActive(Value: Boolean);
    procedure SetShowDesign(Value: Boolean);
    procedure IconChanged(Sender: TObject);
    procedure WndProc(var Message: TMessage);
    function GetActiveIcon: TIcon;
    function IsMainFormActive: Boolean;
    procedure HookApp;
    procedure UnhookApp;
    procedure HookAppProc(var Message: TMessage);
  protected
    procedure DblClick; dynamic;
    procedure DoClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure UpdateNotifyData; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Hide;
    procedure Show;
    property Handle: HWnd read FHandle;
  published
    property Active: Boolean read FActive write SetActive default True;
    property Enabled: Boolean read FEnabled write FEnabled default True;
    property Hint: String read FHint write SetHint;
    property HideMainForm: Boolean read FHideMainForm write SetHideMainForm default True;
    property MinimizeToTray: Boolean read FMinimizeToTray write FMinimizeToTray default True;
    property MinimizeAllForm: Boolean read FMinimizeAllForm write FMinimizeAllForm default True;
    property Icon: TIcon read FIcon write SetIcon;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property ShowDesign: Boolean read FShowDesign write SetShowDesign stored False;
    property OnClick: TMouseEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
    property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;

const
  CM_TRAYICON = CM_BASE + 84;
  MaxExtStrID = 61300;
  SFileNotExec = MaxExtStrID - 44;
  
implementation

procedure SwitchToWindow(Wnd: HWnd; Restore: Boolean);
begin
  if IsWindowEnabled(Wnd) then
  begin
    SetForegroundWindow(Wnd);
    if Restore and IsWindowVisible(Wnd) then
    begin
      if not IsZoomed(Wnd) then
        SendMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);
      SetFocus(Wnd);
    end;
  end;
end;

{ TAYTrayIcon }

constructor TTrayIcon.Create(AOwner: Tcomponent);
begin
  inherited Create(AOwner);
  FHandle := AllocateHWnd(WndProc);
  FIcon := TIcon.Create;
  FIcon.OnChange := IconChanged;
  FIconIndex := -1;
  FEnabled := True;
  FInterval := 150;
  FActive := True;
  FMinimizeToTray := True;
  FMinimizeAllForm:= True;
  FHideMainForm := True;
  if Not (csDesigning in ComponentState) then
  begin
    HookApp;
    HideMainForm := True;
  end;
end;

destructor TTrayIcon.Destroy;
begin
  FEnabled := False;
  FIcon.OnChange := Nil;
  Deactivate;
  DeallocateHWnd(FHandle);
  FIcon.Free;
  FIcon := Nil;

  if Not (csDesigning in ComponentState) then
    UnhookApp;
  inherited Destroy;
end;

procedure TTrayIcon.Loaded;
begin
  inherited Loaded;
  if FActive and not (csDesigning in ComponentState) then Activate;
end;

procedure TTrayIcon.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = PopupMenu) and (Operation = opRemove) then
    PopupMenu := nil;
end;

procedure TTrayIcon.SetPopupMenu(Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TTrayIcon.SendCancelMode;
var
  F: TForm;
begin
  if not (csDestroying in ComponentState) then begin
    F := Screen.ActiveForm;
    if F = nil then F := Application.MainForm;
    if F <> nil then F.SendCancelMode(nil);
  end;
end;

function TTrayIcon.CheckMenuPopup(X, Y: Integer): Boolean;
begin
  Result := False;
  if not (csDesigning in ComponentState) and Active and
    (PopupMenu <> nil) and PopupMenu.AutoPopup then
  begin
    PopupMenu.PopupComponent := Self;
    SendCancelMode;
    SwitchToWindow(FHandle, False);
    Application.ProcessMessages;
    try
      PopupMenu.Popup(X, Y);
    finally
      SwitchToWindow(FHandle, False);
    end;
    Result := True;
  end;
end;

function TTrayIcon.CheckDefaultMenuItem: Boolean;
var
  Item: TMenuItem;
  I: Integer;
begin
  Result := False;
  if not (csDesigning in ComponentState) and Active and
    (PopupMenu <> nil) and (PopupMenu.Items <> nil) then
  begin
    I := 0;
    while (I < PopupMenu.Items.Count) do begin
      Item := PopupMenu.Items[I];
      if Item.Default and Item.Enabled then begin
        Item.Click;
        Result := True;
        Break;
      end;
      Inc(I);
    end;
  end;
end;

procedure TTrayIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
end;

function TTrayIcon.GetActiveIcon: TIcon;
begin
  Result := FIcon;
end;

procedure TTrayIcon.HookApp;
begin
  OldAppProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
  NewAppProc := MakeObjectInstance(HookAppProc);
  SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(NewAppProc));
end;


procedure TTrayIcon.UnhookApp;
begin
  if Assigned(OldAppProc) then
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldAppProc));
  if Assigned(NewAppProc) then
    FreeObjectInstance(NewAppProc);
  NewAppProc := nil;
  OldAppProc := nil;
end;

function TTrayIcon.IsMainFormActive: Boolean;
var
  i: Integer;
  FActiveForm: TForm;
begin
  With Screen Do begin
    FActiveForm := Nil;
    For i := 0 To FormCount - 1 Do begin
      if Forms[i].Active or Forms[i].Visible then
      begin
        FActiveForm := Forms[i];
        Break;
      end;
    end;
    if Assigned(FActiveForm) then
      Result := (FActiveForm = Application.MainForm)
    else
      Result := True;
  end;
end;

procedure TTrayIcon.HookAppProc(var Message: TMessage);
begin
  With Message Do begin
    Case Msg Of
      WM_SIZE:
        if wParam = SIZE_MINIMIZED then
        begin
          if FMinimizeToTray and (FMinimizeAllForm or IsMainFormActive) then
          begin
            Application.MainForm.Visible:= False;
            ShowWindow(Application.Handle, SW_HIDE);
            ShowWindow(Application.MainForm.Handle, SW_HIDE);
          end
          else begin
            Msg := 0;
          end;
        end;
      WM_YBAPPFORMSHOW:
        begin
          if Application.MainForm.Active or Application.MainForm.Visible then
          begin
            Application.MainForm.Visible := False;
            ShowWindow(Application.MainForm.Handle, SW_HIDE);
          end;
        end;
    End;
    Result := CallWindowProc(OldAppProc, Application.Handle, Msg, wParam, lParam);
  end;
end;

procedure TTrayIcon.SetActive(Value: Boolean);
begin
  if (Value <> FActive) then begin
    FActive := Value;
    if not (csDesigning in ComponentState) then
      if Value then Activate else Deactivate;
  end;
end;

procedure TTrayIcon.Show;
begin
  Active := True;
end;

procedure TTrayIcon.Hide;
begin
  Active := False;
end;

procedure TTrayIcon.SetShowDesign(Value: Boolean);
begin
  if (csDesigning in ComponentState) then begin
    if Value then Activate else Deactivate;
    FShowDesign := FAdded;
  end;
end;

procedure TTrayIcon.IconChanged(Sender: TObject);
begin
  ChangeIcon;
end;

procedure TTrayIcon.SetHideMainForm(Value: Boolean);
begin
  FHideMainForm := Value;
  Application.ShowMainForm := Not Value;
end;

procedure TTrayIcon.SetHint(const Value: string);
begin
  if FHint <> Value then begin
    FHint := Value;
    ChangeIcon;
  end;
end;

procedure TTrayIcon.UpdateNotifyData;
var
  Ico: TIcon;
begin
  with FIconData do begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := FHandle;
    uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
    Ico := GetActiveIcon;
    if Ico <> nil then hIcon := Ico.Handle
    else hIcon := INVALID_HANDLE_VALUE;
    StrPLCopy(szTip, GetShortHint(FHint), SizeOf(szTip) - 1);
    uCallbackMessage := CM_TRAYICON;
    uID := 0;
  end;
end;

procedure TTrayIcon.Activate;
var
  Ico: TIcon;
begin
  Deactivate;
  Ico := GetActiveIcon;
  if (Ico <> nil) and not Ico.Empty then begin
    FClicked := [];
    UpdateNotifyData;
    FAdded := Shell_NotifyIcon(NIM_ADD, @FIconData);
    if (GetShortHint(FHint) = '') and FAdded then
      Shell_NotifyIcon(NIM_MODIFY, @FIconData);
  end;
end;

procedure TTrayIcon.Deactivate;
begin
  Shell_NotifyIcon(NIM_DELETE, @FIconData);
  FAdded := False;
  FClicked := [];
end;

procedure TTrayIcon.ChangeIcon;
var
  Ico: TIcon;
begin
  if FAdded then begin
    Ico := GetActiveIcon;
    if (Ico <> nil) and not Ico.Empty then begin
      UpdateNotifyData;
      Shell_NotifyIcon(NIM_MODIFY, @FIconData);
    end
    else Deactivate;
  end
  else begin
    if ((csDesigning in ComponentState) and FShowDesign) or
      (not (csDesigning in ComponentState) and FActive) then Activate;
  end;
end;

procedure TTrayIcon.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
end;

procedure TTrayIcon.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TTrayIcon.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TTrayIcon.DblClick;
begin
  if FMinimizeToTray and (FMinimizeAllForm or IsMainFormActive) then
  begin
    Application.Restore;
    Application.MainForm.Show;
    SetForegroundWindow(Application.MainForm.Handle);
  end;
  if not CheckDefaultMenuItem and Assigned(FOnDblClick) then
    FOnDblClick(Self);
end;

procedure TTrayIcon.DoClick(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Button = mbRight) and CheckMenuPopup(X, Y) then Exit;
  if Assigned(FOnClick) then FOnClick(Self, Button, Shift, X, Y);
end;

procedure TTrayIcon.WndProc(var Message: TMessage);

  function GetShiftState: TShiftState;
  begin
    Result := [];
    if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
    if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
    if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
  end;

var
  P: TPoint;
  Shift: TShiftState;
begin
  try
    with Message do
      if (Msg = CM_TRAYICON) and Self.FEnabled then begin
        case lParam of
          WM_LBUTTONDBLCLK:
            begin
              DblClick;
              GetCursorPos(P);
              MouseDown(mbLeft, GetShiftState + [ssDouble], P.X, P.Y);
            end;
          WM_RBUTTONDBLCLK:
            begin
              GetCursorPos(P);
              MouseDown(mbRight, GetShiftState + [ssDouble], P.X, P.Y);
            end;
          WM_MBUTTONDBLCLK:
            begin
              GetCursorPos(P);
              MouseDown(mbMiddle, GetShiftState + [ssDouble], P.X, P.Y);
            end;
          WM_MOUSEMOVE:
            begin
              GetCursorPos(P);
              MouseMove(GetShiftState, P.X, P.Y);
            end;
          WM_LBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbLeft, GetShiftState + [ssLeft], P.X, P.Y);
              Include(FClicked, mbLeft);
            end;
          WM_LBUTTONUP:
            begin
              Shift := GetShiftState + [ssLeft];
              GetCursorPos(P);
              if mbLeft in FClicked then begin
                Exclude(FClicked, mbLeft);
                DoClick(mbLeft, Shift, P.X, P.Y);
              end;
              MouseUp(mbLeft, Shift, P.X, P.Y);
            end;
          WM_RBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbRight, GetShiftState + [ssRight], P.X, P.Y);
              Include(FClicked, mbRight);
            end;
          WM_RBUTTONUP:
            begin
              Shift := GetShiftState + [ssRight];
              GetCursorPos(P);
              if mbRight in FClicked then begin
                Exclude(FClicked, mbRight);
                DoClick(mbRight, Shift, P.X, P.Y);
              end;
              MouseUp(mbRight, Shift, P.X, P.Y);
            end;
          WM_MBUTTONDOWN:
            begin
              GetCursorPos(P);
              MouseDown(mbMiddle, GetShiftState + [ssMiddle], P.X, P.Y);
            end;
          WM_MBUTTONUP:
            begin
              GetCursorPos(P);
              MouseUp(mbMiddle, GetShiftState + [ssMiddle], P.X, P.Y);
            end;
        end;
      end
      else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
  except
    Application.HandleException(Self);
  end;
end;

end.
